home *** CD-ROM | disk | FTP | other *** search
/ EnigmA Amiga Run 1995 November / EnigmA AMIGA RUN 02 (1995)(G.R. Edizioni)(IT)[!][issue 1995-11][Skylink CD].iso / earcd / program / misc / obrn-a_1.lha / oberon-a / src_upd1.lha / source / oc / OCP.mod < prev    next >
Text File  |  1995-07-13  |  38KB  |  1,123 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCP.mod $
  4.   Description: Code selection for standard procedures
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.17 $
  8.       $Author: fjc $
  9.         $Date: 1995/07/14 00:43:53 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *> <*$ LongVars+ *>
  21.  
  22. MODULE OCP;
  23.  
  24. IMPORT SYS := SYSTEM, OCM, OCS, OCT, OCC, OCI, OCE;
  25.  
  26.  
  27. (* --- Local declarations ----------------------------------------------- *)
  28.  
  29. CONST
  30.  
  31.   (* object modes *)
  32.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  33.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  34.   Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop; Coc = OCM.Coc;
  35.   Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ; Abs = OCM.Abs;
  36.   XProc = OCM.XProc; LProc = OCM.LProc;
  37.  
  38.   (* System flags *)
  39.  
  40.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  41.   BCPLFlag = OCM.BCPLFlag; AsmFlag = OCM.AsmFlag;
  42.  
  43.   (* structure forms *)
  44.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  45.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  46.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  47.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  48.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  49.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; AdrTyp = OCT.AdrTyp;
  50.   BPtrTyp = OCT.BPtrTyp; BSet = OCT.BSet; WSet = OCT.WSet; Word = OCT.Word;
  51.   Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  52.  
  53.   intSet   = {SInt, Int, LInt};
  54.   realSet  = {Real, LReal};
  55.   setSet   = {BSet, WSet, Set};
  56.   ptrSet   = {Pointer, PtrTyp, AdrTyp, BPtrTyp};
  57.   uptrSet  = {AdrTyp, BPtrTyp};
  58.   allSet   = {0 .. 31};
  59.   adrSet   = {LInt, Pointer, PtrTyp, AdrTyp, Longword};
  60.   bitOpSet = intSet + setSet + {Byte, Char, Word, Longword};
  61.   putSet   =
  62.     {Undef .. LInt, Word, Longword, ProcTyp} + setSet + ptrSet + realSet;
  63.  
  64.   (* CPU Registers *)
  65.  
  66.   D0 = 0; D1 = 1; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  67.   A6 = 14; A7 = 15; BP = A4; FP = A5; SP = A7;
  68.   DataRegs = {D0 .. D7};
  69.   AdrRegs = {A0 .. A7};
  70.  
  71.   (* Data sizes *)
  72.  
  73.   B = 1; W = 2; L = 4;
  74.  
  75. (* --- Procedure declarations ------------------------------------------- *)
  76.  
  77. (*------------------------------------*)
  78. PROCEDURE CheckCleanupProc (VAR x : OCT.Item);
  79.  
  80.   VAR par : OCT.Object; typ : OCT.Struct;
  81.  
  82. BEGIN (* CheckCleanupProc *)
  83.   IF (x.mode = XProc) OR (x.typ.form = ProcTyp) THEN
  84.     IF x.mode = XProc THEN par := x.obj.link; typ := x.typ
  85.     ELSE par := x.typ.link; typ := x.typ.BaseTyp;
  86.     END;
  87.     IF OCT.IsParam (par) THEN OCS.Mark (117) END;
  88.     IF typ # OCT.notyp THEN OCS.Mark (301) END
  89.   ELSE
  90.     OCS.Mark (300)
  91.   END
  92. END CheckCleanupProc;
  93.  
  94. (*----------------------------%-------*)
  95. PROCEDURE NeedsTag (typ : OCT.Struct) : BOOLEAN;
  96.  
  97.   VAR fld : OCT.Object;
  98.  
  99. BEGIN (* NeedsTag *)
  100.   IF (typ.form IN {Pointer, Record}) & (typ.sysflg = OberonFlag) THEN
  101.     RETURN TRUE
  102.   ELSIF typ.form IN {Array, DynArr} THEN
  103.     RETURN NeedsTag (typ.BaseTyp)
  104.   END;
  105.   RETURN FALSE
  106. END NeedsTag;
  107.  
  108. (*------------------------------------*)
  109. PROCEDURE SaveRegs * ( fctno : INTEGER; VAR R : OCC.RegState );
  110.  
  111.   VAR x : OCT.Item;
  112.  
  113. BEGIN (* SaveRegs *)
  114.   CASE fctno OF
  115.     OCT.pDISPOSE, OCT.pMOVE :
  116.       x.mode := Undef; OCC.SaveRegisters (R, x, OCC.AllRegs)
  117.     |
  118.   ELSE
  119.     R.regs := {}
  120.   END
  121. END SaveRegs;
  122.  
  123. (*------------------------------------*)
  124. PROCEDURE StPar1 *
  125.   ( VAR x : OCT.Item; fctno : INTEGER; VAR R : OCC.RegState );
  126.  
  127.   VAR f, f1 : INTEGER; y, z, r0, r1 : OCT.Item;
  128.       size : LONGINT; par : OCT.Object;
  129.       typ : OCT.Struct; desc : OCT.Desc; s : SET;
  130.  
  131.   (*------------------------------------*)
  132.   PROCEDURE GetTag (VAR x : OCT.Item);
  133.  
  134.     VAR y, z : OCT.Item;
  135.  
  136.   BEGIN (* GetTag *)
  137.     IF OCC.InAdrReg (x.obj) THEN
  138.       OCC.GetAReg (x, x.obj)
  139.     ELSE
  140.       y := x; y.obj := NIL; y.typ := OCT.ptrtyp; OCC.GetAReg (x, x.obj);
  141.       IF OCS.pragma [OCS.nilChk] THEN
  142.         OCC.GetDReg (z, NIL); OCC.Move (L, y, z);      (* MOVE.L  x,Dn   *)
  143.         OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  144.         OCC.Move (L, z, x); OCI.Unload (z)             (* MOVEA.L Dn, An *)
  145.       ELSE
  146.         OCC.Move (L, y, x);                            (* MOVEA.L x, An  *)
  147.       END;
  148.       OCI.Unload (y)
  149.     END;
  150.     x.mode := RegI; x.a1 := -4; x.a2 := 0; x.obj := OCC.wasderef;
  151.     x.rdOnly := FALSE;
  152.   END GetTag;
  153.  
  154. BEGIN (* StPar1 *)
  155.   f := x.typ.form; size := x.typ.size;
  156.   CASE fctno OF
  157.     OCT.pABS :
  158.       IF f IN intSet THEN
  159.         IF x.mode = Con THEN
  160.           x.a0 := ABS (x.a0)
  161.         ELSE
  162.           OCI.Load (x);                                (*    MOVE.z  x,Dn *)
  163.           OCC.PutF1 (OCC.TST, size, x);                (*    TST.z   Dn   *)
  164.           OCC.PutWord (6A02H);                         (*    BPL     1$   *)
  165.           OCC.PutF1 (OCC.NEG, size, x)                 (*    NEG.z   Dn   *)
  166.         END
  167.       ELSIF f IN realSet THEN
  168.         OCC.LoadRegParams1 (R, x);
  169.         OCC.CallKernel (OCC.kSPAbs);
  170.         OCC.RestoreRegisters (R, x)
  171.       ELSE
  172.         OCS.Mark (111)
  173.       END
  174.     |
  175.     OCT.pCAP :
  176.       IF (f = String) & (x.a1 <= 2) THEN
  177.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  178.       END;
  179.       IF f = Char THEN
  180.         IF x.mode = Con THEN
  181.           x.a0 := ORD (CAP (CHR (x.a0)))
  182.         ELSE
  183.           y.mode := Con; y.typ := OCT.chartyp;
  184.           OCI.Load (x);                                (*    MOVE x,Dn    *)
  185.           y.a0 := ORD ("a");
  186.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "a", Dn *)
  187.           OCC.PutWord (6510H);                         (*    BCS 1$       *)
  188.           y.a0 := ORD ("z");
  189.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "z", Dn *)
  190.           OCC.PutWord (6306H);                         (*    BLS 0$       *)
  191.           y.a0 := 0E0H; OCC.PutF6 (OCC.CMPI, B, y, x); (*    CMPI 0E0X,Dn *)
  192.           OCC.PutWord (6504H);                         (*    BCS 1$       *)
  193.           y.a0 := 0DFH; OCC.PutF6 (OCC.ANDI, B, y, x); (* 0$ ANDI 0DFH,Dn *)
  194.         END                                            (* 1$              *)
  195.       ELSE
  196.         OCS.Mark (111); x.typ := OCT.chartyp
  197.       END
  198.     |
  199.     OCT.pCHR :
  200.       IF ~(f IN {Undef, Byte, SInt, Int, LInt}) THEN OCS.Mark (111) END;
  201.       IF ~(f IN {Byte, SInt}) & (x.mode # Con) THEN OCI.Load (x) END;
  202.       x.typ := OCT.chartyp
  203.     |
  204.     OCT.pENTIER :
  205.       IF f IN realSet THEN
  206.         OCC.LoadRegParams1 (R, x);
  207.         OCC.CallKernel (OCC.kSPFix);
  208.         OCC.RestoreRegisters (R, x)
  209.       ELSE OCS.Mark (111)
  210.       END;
  211.       x.typ := OCT.linttyp;
  212.     |
  213.     OCT.pHALT :
  214.       IF (f IN intSet) & (x.mode = Con) THEN
  215.         r0.mode := Reg; r0.a0 := D0;
  216.         OCC.Move (L, x, r0);                     (* MOVE.L x,D0          *)
  217.         y.mode := Con; y.a0 := 0; y.typ := OCT.stringtyp;
  218.         y.label := OCT.ConstLabel;
  219.         OCC.PutF2 (OCC.LEA, y, A0);              (* LEA    ModuleName,A0 *)
  220.         y.a0 := (OCS.line * 10000H) + OCS.col; y.typ := OCT.linttyp;
  221.         r1.mode := Reg; r1.a0 := D1;
  222.         OCC.Move (L, y, r1);                     (* MOVE.L pos,D1        *)
  223.         OCC.CallKernel (OCC.kHalt)               (* JSR    Kernel_Halt   *)
  224.       ELSE
  225.         OCS.Mark (17)
  226.       END;
  227.       x.typ := OCT.notyp
  228.     |
  229.     OCT.pLONG :
  230.       IF (f = String) & (x.a1 <= 2) THEN
  231.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  232.       END;
  233.       IF f = SInt THEN OCE.ConvertInts (x, OCT.inttyp)
  234.       ELSIF f = Int THEN OCE.ConvertInts (x, OCT.linttyp)
  235.       ELSIF f = BSet THEN
  236.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  237.         IF x.mode # Con THEN
  238.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.wsettyp;
  239.           OCI.Load (x); OCC.Move (B, y, x)
  240.         END;
  241.         x.typ := OCT.wsettyp
  242.       ELSIF f = WSet THEN
  243.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  244.         IF x.mode # Con THEN
  245.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.settyp;
  246.           OCI.Load (x); OCC.Move (W, y, x)
  247.         END;
  248.         x.typ := OCT.settyp
  249.       ELSIF f = Real THEN
  250.         x.typ := OCT.lrltyp
  251.       ELSIF f = Char THEN
  252.         IF x.mode # Con THEN
  253.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  254.           OCI.Load (x); OCC.Move (B, y, x)
  255.         END;
  256.         x.typ := OCT.linttyp
  257.       ELSE
  258.         OCS.Mark (111)
  259.       END
  260.     |
  261.     OCT.pMAX :
  262.       IF x.mode = Typ THEN
  263.         x.mode := Con;
  264.         CASE f OF
  265.           Bool  : x.a0 := OCM.MaxBool                      |
  266.           Char  : x.a0 := OCM.MaxChar                      |
  267.           SInt  : x.a0 := OCM.MaxSInt                      |
  268.           Int   : x.a0 := OCM.MaxInt                       |
  269.           LInt  : x.a0 := OCM.MaxLInt                      |
  270.           Real  : x.a0 := 07F7FFFFFH                       |
  271.           LReal : x.a0 := 07F7FFFFFH                       |
  272.           BSet  : x.a0 := OCM.MaxBSet; x.typ := OCT.inttyp |
  273.           WSet  : x.a0 := OCM.MaxWSet; x.typ := OCT.inttyp |
  274.           Set   : x.a0 := OCM.MaxSet; x.typ := OCT.inttyp  |
  275.         ELSE
  276.           OCS.Mark (111)
  277.         END; (* CASE f *)
  278.       ELSE
  279.         OCS.Mark (110)
  280.       END
  281.     |
  282.     OCT.pMIN :
  283.       IF x.mode = Typ THEN
  284.         x.mode := Con;
  285.         CASE f OF
  286.           Bool  : x.a0 := OCM.MinBool                               |
  287.           Char  : x.a0 := OCM.MinChar                               |
  288.           SInt  : x.a0 := OCM.MinSInt                               |
  289.           Int   : x.a0 := OCM.MinInt                                |
  290.           LInt  : x.a0 := OCM.MinLInt                               |
  291.           Real  : x.a0 := 0FF7FFFFFH                                |
  292.           LReal : x.a0 := 0FF7FFFFFH                                |
  293.           BSet, WSet, Set : x.a0 := OCM.MinSet; x.typ := OCT.inttyp |
  294.         ELSE
  295.           OCS.Mark (111)
  296.         END; (* CASE f *)
  297.       ELSE
  298.         OCS.Mark (110)
  299.       END
  300.     |
  301.     OCT.pNEW :
  302.       IF (f = Pointer) & (x.mode # Con) THEN
  303.         IF x.rdOnly THEN OCS.Mark (324) END;
  304.         typ := x.typ; f1 := typ.sysflg;
  305.         typ := typ.BaseTyp; f := typ.form;
  306.         IF f = DynArr THEN
  307.           OCI.UnloadDesc (x);
  308.           desc := x.desc; IF desc = NIL THEN NEW (desc) END;
  309.           desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  310.           desc.a1 := x.a1; desc.a2 := x.a2; x.desc := desc;
  311.         END;
  312.         z.mode := Undef; OCC.SaveRegisters (R, z, OCC.AllRegs);
  313.         IF (f = DynArr) & (x.mode IN {VarX, IndX, RegI, RegX}) THEN
  314.           IF x.mode IN {RegI, RegX} THEN OCC.ReserveReg (x.a0, NIL) END;
  315.           IF x.mode # RegI THEN OCC.ReserveReg (x.a2, NIL) END
  316.         END;
  317.         z.mode := Push; z.a0 := SP;
  318.         IF (f1 = OberonFlag) & NeedsTag (typ) THEN
  319.           IF f = DynArr THEN
  320.             WHILE typ.form = DynArr DO typ := typ.BaseTyp END;
  321.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  322.           ELSIF f = Array THEN
  323.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  324.           END;
  325.           y.mode := Con; y.a0 := 0; y.typ := OCT.tagtyp;
  326.           y.label := typ.label;
  327.           OCC.PutF3 (OCC.PEA, y);                 (* PEA #tag            *)
  328.           IF f = Array THEN
  329.             y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  330.             OCC.Move (L, y, z);                   (* MOVE.L #size,-(A7)  *)
  331.           END
  332.         ELSIF f # DynArr THEN
  333.           y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  334.           OCC.Move (L, y, z);                     (* MOVE.L #size, -(A7) *)
  335.         END
  336.       ELSE OCS.Mark (111)
  337.       END
  338.     |
  339.     OCT.pODD :
  340.       IF f IN intSet THEN
  341.         y.mode := Con; y.a0 := 0; y.typ := OCT.inttyp;
  342.         IF f = SInt THEN OCC.Bit (OCC.BTST, y, x);
  343.         ELSE OCI.Load (x); OCC.Bit (OCC.BTST, y, x); OCI.Unload (x)
  344.         END;
  345.       ELSE
  346.         OCS.Mark (111)
  347.       END;
  348.       OCE.setCC (x, OCC.NE)
  349.     |
  350.     OCT.pORD :
  351.       IF (f = String) & (x.a1 <= 2) THEN
  352.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  353.       END;
  354.       IF (f = Char) OR (f = Byte) THEN
  355.         IF x.mode # Con THEN
  356.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.inttyp;
  357.           OCI.Load (x); OCC.Move (B, y, x)
  358.         END
  359.       ELSE
  360.         OCS.Mark (111)
  361.       END;
  362.       x.typ := OCT.inttyp
  363.     |
  364.     OCT.pSHORT :
  365.       IF f = LInt THEN
  366.         IF x.mode = Con THEN
  367.           OCE.SetIntType (x); IF x.typ.form = LInt THEN OCS.Mark (203) END
  368.         ELSE
  369.           OCI.Load (x);
  370.           IF OCS.pragma [OCS.rangeChk] THEN
  371.             OCC.GetDReg (y, NIL); OCC.Move (W, x, y); OCI.EXT (L, y.a0);
  372.             OCI.CMP (L, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  373.           END
  374.         END;
  375.         x.typ := OCT.inttyp
  376.       ELSIF f = Int THEN
  377.         IF x.mode = Con THEN
  378.           OCE.SetIntType (x); IF x.typ.form # SInt THEN OCS.Mark (203) END
  379.         ELSE
  380.           OCI.Load (x);
  381.           IF OCS.pragma [OCS.rangeChk] THEN
  382.             OCC.GetDReg (y, NIL); OCC.Move (B, x, y); OCI.EXT (W, y.a0);
  383.             OCI.CMP (W, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  384.           END
  385.         END;
  386.         x.typ := OCT.sinttyp
  387.       ELSIF f = Set THEN
  388.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  389.         IF x.mode = Con THEN
  390.           s := SYS.VAL (SET, x.a0);
  391.           IF (s - {0..15}) # {} THEN OCS.Mark (203) END;
  392.         ELSE
  393.           OCI.Load (x);
  394.           IF OCS.pragma [OCS.rangeChk] THEN
  395.             y.mode := Con; y.a0 := 0; y.typ := OCT.linttyp;
  396.             OCI.Load (y); OCC.Move (W, x, y);
  397.             OCI.CMP (L, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE);
  398.           END
  399.         END;
  400.         x.typ := OCT.wsettyp
  401.       ELSIF f = WSet THEN
  402.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  403.         IF x.mode = Con THEN
  404.           s := SYS.VAL (SET, x.a0);
  405.           IF (s - {0..7}) # {} THEN OCS.Mark (203) END;
  406.         ELSE
  407.           OCI.Load (x);
  408.           IF OCS.pragma [OCS.rangeChk] THEN
  409.             y.mode := Con; y.a0 := 0; y.typ := OCT.linttyp;
  410.             OCI.Load (y); OCC.Move (B, x, y);
  411.             OCI.CMP (W, x, y); OCC.TrapCC (OCC.RangeCheck, OCC.NE)
  412.           END
  413.         END;
  414.         x.typ := OCT.bsettyp
  415.       ELSIF f = LReal THEN
  416.         x.typ := OCT.realtyp
  417.       ELSE
  418.         OCS.Mark (111)
  419.       END
  420.     |
  421.     OCT.pADR :
  422.       IF OCM.SmallData & (x.mode = Con) & (x.typ = OCT.stringtyp) THEN
  423.         (* Special casing to avoid the exhaustion of address registers
  424.         ** during processing of VarArgs.
  425.         *)
  426.         IF x.a1 < 3 THEN OCC.AllocStringFromChar (x) END;
  427.         x.mode := LabI; x.a1 := L
  428.       ELSE
  429.         OCI.Adr (x)
  430.       END;
  431.       x.typ := OCT.adrtyp
  432.     |
  433.     OCT.pCC :
  434.       IF (f = SInt) & (x.mode = Con) THEN
  435.         IF (x.a0 >= 0) & (x.a0 < 16) THEN OCE.setCC (x, x.a0)
  436.         ELSE OCS.Mark (219)
  437.         END
  438.       ELSE OCS.Mark (17)
  439.       END
  440.     |
  441.     OCT.pDISPOSE :
  442.       IF f IN ptrSet THEN
  443.         IF x.rdOnly THEN OCS.Mark (324) END;
  444.         IF x.typ.sysflg = BCPLFlag THEN
  445.           y := x; OCI.Load (y);
  446.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  447.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  448.           OCC.Move (L, y, x); OCI.Unload (y)
  449.         END;
  450.         y.mode := Push; y.a0 := SP;
  451.         OCC.ForgetObj (x.obj);
  452.         IF x.mode IN {Ind, IndX} THEN OCI.MoveAdr (x, y)
  453.         ELSE OCC.PutF3 (OCC.PEA, x)
  454.         END;
  455.         OCI.Unload (x);
  456.         OCC.CallKernel (OCC.kDispose);
  457.         z.mode := Undef; OCC.ForgetRegs; OCC.RestoreRegisters (R, z)
  458.       ELSE
  459.         OCS.Mark (111)
  460.       END;
  461.       x.typ := OCT.notyp
  462.     |
  463.     OCT.pSIZE :
  464.       IF x.mode = Typ THEN x.a0 := x.typ.size
  465.       ELSE OCS.Mark (110); x.a0 := 1
  466.       END;
  467.       x.mode := Con; OCE.SetIntType (x)
  468.     |
  469.     OCT.pSTRLEN :
  470.       IF ((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char) THEN
  471.         y := x; OCI.LoadAdr (y); y.mode := Pop;       (*    LEA    <y>,Ay *)
  472.         OCC.ForgetReg (y.a0);
  473.         x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  474.         OCI.Load (x);                                 (*    MOVEQ  #0,Dx  *)
  475.         OCC.PutF1 (OCC.TST, B, y); OCC.FreeReg (y);   (* 1$ TST.B  (Ay)+  *)
  476.         OCC.PutWord (6704H);                          (*    BEQ    2$     *)
  477.         OCC.PutF7 (OCC.ADDQ, L, 1, x);                (*    ADDQ.L #1,Dx  *)
  478.         OCC.PutWord (60F8H);                          (*    BRA    1$     *)
  479.       ELSIF f = String THEN                           (* 2$               *)
  480.         x.mode := Con; x.a0 := x.a1 - 1; x.typ := OCT.linttyp
  481.       ELSE
  482.         OCS.Mark (111)
  483.       END
  484.     |
  485.     OCT.pASH :
  486.       IF f IN intSet THEN
  487.         OCI.Load (x); IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END
  488.       ELSE
  489.         OCS.Mark (111)
  490.       END
  491.     |
  492.     OCT.pASSERT :
  493.       IF f = Bool THEN
  494.         IF x.mode = Con THEN
  495.           IF x.a0 = 0 THEN OCS.Mark (319) ELSE OCS.Mark (320) END;
  496.           OCE.setCC (x, OCC.T)
  497.         END;
  498.       ELSE OCS.Mark (120)
  499.       END
  500.     |
  501.     OCT.pCOPY :
  502.       IF
  503.         ~((((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char))
  504.           OR (f = String))
  505.       THEN
  506.         OCS.Mark (111)
  507.       END
  508.     |
  509.     OCT.pDEC, OCT.pINC :
  510.       IF x.mode >= Con THEN     OCS.Mark (112)
  511.       ELSIF ~(f IN intSet) THEN OCS.Mark (111)
  512.       ELSIF x.rdOnly THEN OCS.Mark (324)
  513.       END
  514.     |
  515.     OCT.pINCL, OCT.pEXCL :
  516.       IF x.mode >= Con THEN     OCS.Mark (112)
  517.       ELSIF ~(f IN setSet) THEN OCS.Mark (111); x.typ := OCT.settyp
  518.       ELSIF x.rdOnly THEN OCS.Mark (324)
  519.       END
  520.     |
  521.     OCT.pLEN :
  522.       IF (f # DynArr) & (f # Array) THEN OCS.Mark (131) END
  523.     |
  524.     OCT.pAND, OCT.pOR, OCT.pXOR :
  525.       IF ~(f IN bitOpSet) THEN OCS.Mark (111) END
  526.     |
  527.     OCT.pBIT, OCT.pGET, OCT.pPUT :
  528.       IF (f IN intSet) & (x.mode = Con) THEN
  529.         x.mode := Abs; x.obj := NIL
  530.       ELSIF f IN adrSet THEN
  531.         IF x.mode = Var THEN
  532.           x.mode := Ind; x.a1 := 0
  533.         ELSE
  534.           OCC.GetAReg (y, NIL); x.obj := NIL; OCC.Move (L, x, y);
  535.           x := y; x.mode := RegI; x.a1 := 0
  536.         END
  537.       ELSE
  538.         OCS.Mark (111)
  539.       END
  540.     |
  541.     OCT.pGETREG, OCT.pPUTREG, OCT.pREG :
  542.       IF (f IN intSet) & (x.mode = Con) THEN
  543.         IF (0 <= x.a0) & (x.a0 <= 15) THEN
  544.           x.mode := Reg;
  545.           IF fctno = OCT.pREG THEN
  546.             OCC.ReserveReg (x.a0, NIL); x.typ := OCT.lwordtyp
  547.           END
  548.         ELSE OCS.Mark (219)
  549.         END
  550.       ELSE
  551.         OCS.Mark (17)
  552.       END
  553.     |
  554.     OCT.pLSH, OCT.pROT :
  555.       IF (f = String) & (x.a1 <= 2) THEN
  556.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  557.       END;
  558.       IF f IN bitOpSet THEN OCI.Load (x)
  559.       ELSE OCS.Mark (111)
  560.       END
  561.     |
  562.     OCT.pSYSNEW :
  563.       IF ~(f IN ptrSet) OR (x.mode = Con) THEN OCS.Mark (111)
  564.       ELSIF x.rdOnly THEN OCS.Mark (324)
  565.       ELSIF NeedsTag (x.typ) THEN OCS.Mark (339)
  566.       ELSE y.mode := Undef; OCC.SaveRegisters (R, y, OCC.AllRegs)
  567.       END
  568.     |
  569.     OCT.pVAL : IF x.mode # Typ THEN OCS.Mark (110) END
  570.     |
  571.     OCT.pMOVE :
  572.       IF (f IN adrSet) THEN
  573.         y.mode := Push; y.a0 := SP;
  574.         OCC.Move (L, x, y); OCI.Unload (x);
  575.       ELSE
  576.         OCS.Mark (111)
  577.       END
  578.     |
  579.     OCT.pTAG :
  580.       typ := x.typ; f1 := typ.sysflg;
  581.       IF f = Pointer THEN typ := typ.BaseTyp END;
  582.       IF (typ.form = Record) & (f1 = OberonFlag) THEN
  583.         IF x.mode = Typ THEN (* Type *)
  584.           x.mode := Con; x.a0 := 0; x.a1 := 0; x.typ := OCT.tagtyp;
  585.           x.label := typ.label;
  586.           OCI.Adr (x)
  587.         ELSIF (x.mode <= RegX) & (f = Pointer) THEN (* Pointer variable *)
  588.           GetTag (x)
  589.         ELSIF (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef) THEN
  590.           (* VAR parameter *)
  591.           x.mode := Var; x.obj := NIL; INC (x.a0, 4)
  592.         ELSE (* Bzzzzt! *)
  593.           OCS.Mark (338)
  594.         END
  595.       ELSIF f = PtrTyp THEN
  596.         IF (x.mode <= RegX) THEN (* Pointer variable *)
  597.           GetTag (x)
  598.         ELSE (* Bzzzzt! *)
  599.           OCS.Mark (338)
  600.         END
  601.       ELSE
  602.         OCS.Mark (338)
  603.       END;
  604.       x.typ := OCT.tagtyp; x.rdOnly := FALSE
  605.     |
  606.   ELSE
  607.     OCS.Mark (1014); OCS.Mark (fctno)
  608.   END; (* CASE fctno *)
  609. END StPar1;
  610.  
  611. (*------------------------------------*)
  612. PROCEDURE StPar2 *
  613.   ( VAR par1, par2 : OCT.Item; fctno : INTEGER; VAR R : OCC.RegState );
  614.  
  615.   VAR f, dim : INTEGER; L0, L1, op : LONGINT; typ, btyp, t1 : OCT.Struct;
  616.       freePar2 : BOOLEAN; x, y, r0, r1 : OCT.Item;
  617.       dsc : OCT.Desc;
  618.  
  619. BEGIN (* StPar2 *)
  620.   f := par2.typ.form; freePar2 := FALSE;
  621.   IF fctno < OCT.TwoPar THEN OCS.Mark (64); RETURN END;
  622.   CASE fctno OF
  623.     OCT.pASH, OCT.pLSH, OCT.pROT :
  624.       IF
  625.         ((fctno = OCT.pASH) & (f IN intSet)) OR
  626.         ((fctno # OCT.pASH) & (f IN bitOpSet))
  627.       THEN
  628.         IF (par2.mode = Con) & (par2.a0 = 0) THEN RETURN END;
  629.         IF fctno = OCT.pASH THEN op := OCC.ASR
  630.         ELSIF fctno = OCT.pLSH THEN op := OCC.LSR
  631.         ELSE op := OCC.ROR
  632.         END;
  633.         IF par2.mode = Con THEN
  634.           IF par2.a0 < 0 THEN par2.a0 := -par2.a0 ELSE INC (op, 100H) END;
  635.           IF par2.a0 > 8 THEN OCI.Load (par2); freePar2 := TRUE END;
  636.           OCC.Shift (op, par1.typ.size, par2, par1);
  637.           IF freePar2 THEN OCC.FreeReg (par2) END
  638.         ELSE
  639.           OCI.Load (par2);                         (*    MOVE.L <par2>,Dn *)
  640.           OCC.PutF1 (OCC.TST, par2.typ.size, par2);(*    TST.?  Dn        *)
  641.           L0 := OCC.pc; OCC.PutWord (6A00H);       (*    BPL.S  1$        *)
  642.           OCC.PutF1 (OCC.NEG, par2.typ.size, par2);(*    NEG.?  Dn        *)
  643.           OCC.Shift (op, par1.typ.size, par2, par1);
  644.                                                    (*    opR.?  Dn,<par1> *)
  645.           L1 := OCC.pc; OCC.PutWord (6000H);       (*    BRA.S  $2        *)
  646.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  647.           OCC.Shift (op+100H, par1.typ.size, par2, par1);
  648.                                                    (* 1$ opL.?  Dn,<par1> *)
  649.           OCC.PatchWord (L1, OCC.pc - L1 - 2);     (* 2$                  *)
  650.         END
  651.       ELSE
  652.         OCS.Mark (111)
  653.       END
  654.     |
  655.     OCT.pASSERT :
  656.       IF (par2.mode = Con) & (f IN intSet) THEN
  657.         IF par1.mode # Coc THEN
  658.           OCC.PutF1 (OCC.TST, B, par1);          (*    TST.B  <par1>      *)
  659.           OCI.Unload (par1); L0 := OCC.pc;
  660.           OCC.PutWord (OCC.BNE)                  (*    BNE.S  2$          *)
  661.         ELSE
  662.           op := OCC.Bcc + (par1.a0 * 100H);
  663.           OCC.PutWord (op);
  664.           OCC.PutWord (par1.a1);                 (*    Bcc    2$          *)
  665.           L0 := OCC.pc - 2; OCC.FixLink (par1.a2);
  666.         END;
  667.         r0.mode := Reg; r0.a0 := D0;
  668.         OCC.Move (L, par2, r0);               (* 1$ MOVE.L #par2,D0      *)
  669.         OCI.Unload (par2);
  670.         x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  671.         x.label := OCT.ConstLabel;
  672.         OCC.PutF2 (OCC.LEA, x, A0);           (*    LEA    ModuleName,A0 *)
  673.         x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  674.         r1.mode := Reg; r1.a0 := D1;
  675.         OCC.Move (L, x, r1);                  (*    MOVE.L pos,D1        *)
  676.         OCC.CallKernel (OCC.kHalt);           (*    JSR    Kernel.Halt   *)
  677.         OCC.ForgetRegs;
  678.         IF par1.mode # Coc THEN               (* 2$                      *)
  679.           OCC.PatchWord (L0, OCC.pc - L0 - 2)
  680.         ELSE OCC.FixLink (L0)
  681.         END;
  682.       ELSE OCS.Mark (17)
  683.       END;
  684.       par1.typ := OCT.notyp
  685.     |
  686.     OCT.pDEC, OCT.pINC :
  687.       IF par1.typ # par2.typ THEN
  688.         IF (par1.typ.form = Int) & (f = SInt) THEN
  689.           OCE.ConvertInts (par2, OCT.inttyp)
  690.         ELSIF (par1.typ.form = LInt) & (f IN {SInt, Int}) THEN
  691.           OCE.ConvertInts (par2, OCT.linttyp)
  692.         ELSE OCS.Mark (111)
  693.         END
  694.       ELSIF par2.mode # Con THEN
  695.         OCI.Load (par2)
  696.       END;
  697.       IF fctno = OCT.pDEC THEN op := OCC.SUB ELSE op := OCC.ADD END;
  698.       OCC.PutF5 (op, par1.typ.size, par2, par1);
  699.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  700.       par1.typ := OCT.notyp
  701.     |
  702.     OCT.pEXCL :
  703.       OCE.Set0 (x, par2);
  704.       IF x.mode = Con THEN
  705.         x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0));
  706.         OCC.PutF6 (OCC.ANDI, par1.typ.size, x, par1)
  707.       ELSE
  708.         OCC.PutF1 (OCC.NOT, L, x);
  709.         OCC.PutF5 (OCC.AND, par1.typ.size, x, par1)
  710.       END;
  711.       par1.typ := OCT.notyp
  712.     |
  713.     OCT.pINCL :
  714.       OCE.Set0 (x, par2);
  715.       IF x.mode = Con THEN OCC.PutF6 (OCC.ORI, par1.typ.size, x, par1)
  716.       ELSE OCC.PutF5 (OCC.iOR, par1.typ.size, x, par1)
  717.       END;
  718.       par1.typ := OCT.notyp
  719.     |
  720.     OCT.pLEN :
  721.       IF (par2.mode = Con) & (f = SInt) THEN
  722.         dim := SHORT (par2.a0); typ := par1.typ;
  723.         WHILE (dim > 0) & (typ.form IN {DynArr, Array}) DO
  724.           typ := typ.BaseTyp; DEC (dim)
  725.         END;
  726.         IF (dim # 0) OR ~(typ.form IN {DynArr, Array}) THEN OCS.Mark (132)
  727.         ELSE
  728.           IF typ.form = DynArr THEN OCI.DescItem (par1, par1.desc, typ.adr)
  729.           ELSE par1.mode := Con; par1.a0 := typ.n
  730.           END;
  731.           par1.typ := OCT.linttyp
  732.         END
  733.       ELSE
  734.         OCS.Mark (111)
  735.       END
  736.     |
  737.     OCT.pAND, OCT.pOR, OCT.pXOR :
  738.       IF f IN bitOpSet THEN
  739.         IF (par1.mode = Con) & (par2.mode = Con) THEN
  740.           IF fctno = OCT.pAND THEN
  741.             par1.a0 := SYS.AND (par1.a0, par2.a0)
  742.           ELSIF fctno = OCT.pXOR THEN
  743.             par1.a0 := SYS.XOR (par1.a0, par2.a0)
  744.           ELSE
  745.             par1.a0 := SYS.LOR (par1.a0, par2.a0)
  746.           END;
  747.           IF f IN intSet THEN OCE.SetIntType (par1) END
  748.         ELSE
  749.           IF fctno = OCT.pAND THEN op := OCC.AND
  750.           ELSIF fctno = OCT.pXOR THEN op := OCC.EOR
  751.           ELSE op := OCC.iOR
  752.           END;
  753.           IF par1.mode = Con THEN
  754.             IF par1.typ.form # par2.typ.form THEN par1.typ := par2.typ END;
  755.             OCI.Load (par2); OCC.PutF5 (op, par2.typ.size, par1, par2);
  756.             par1 := par2
  757.           ELSIF par2.mode = Con THEN
  758.             IF par2.typ.form # par1.typ.form THEN par2.typ := par1.typ END;
  759.             OCI.Load (par1); OCC.PutF5 (op, par1.typ.size, par2, par1)
  760.           ELSE
  761.             IF par1.typ.form = par2.typ.form THEN
  762.               OCI.Load (par1); IF op = OCC.EOR THEN OCI.Load (par2) END;
  763.               OCC.PutF5 (op, par1.typ.size, par2, par1); OCI.Unload (par2)
  764.             ELSE
  765.               OCS.Mark (100)
  766.             END
  767.           END
  768.         END
  769.       ELSE
  770.         OCS.Mark (111)
  771.       END
  772.     |
  773.     OCT.pBIT :
  774.       IF f IN intSet THEN
  775.         IF (par2.mode = Con) & (par2.a0 >= 8) THEN OCI.Load (par1)
  776.         ELSIF (par2.mode # Con) THEN OCI.Load (par1); OCI.Load (par2)
  777.         END;
  778.         OCC.Bit (OCC.BTST, par2, par1); OCI.Unload (par1); OCI.Unload (par2)
  779.       ELSE
  780.         OCS.Mark (111)
  781.       END;
  782.       OCE.setCC (par1, OCC.NE)
  783.     |
  784.     OCT.pGET, OCT.pGETREG :
  785.       IF par2.mode >= Con THEN OCS.Mark (112)
  786.       ELSIF ~(f IN realSet) THEN
  787.         IF par2.rdOnly THEN OCS.Mark (324) END;
  788.         OCC.Move (par2.typ.size, par1, par2);
  789.         OCC.ForgetObj (par2.obj)
  790.       ELSE OCS.Mark (111)
  791.       END;
  792.       par1.typ := OCT.notyp
  793.     |
  794.     OCT.pPUT, OCT.pPUTREG :
  795.       IF par2.mode IN {XProc, LProc} THEN OCI.MoveAdr (par2, par1)
  796.       ELSIF f IN putSet THEN OCC.Move (par2.typ.size, par2, par1)
  797.       ELSE OCS.Mark (111)
  798.       END;
  799.       par1.typ := OCT.notyp
  800.     |
  801.     OCT.pSYSNEW :
  802.       x.mode := Push; x.a0 := SP;
  803.       IF par2.typ.form # LInt THEN OCE.ConvertInts (par2, OCT.linttyp) END;
  804.       OCC.Move (L, par2, x); OCI.Unload (par2)
  805.     |
  806.     OCT.pVAL : par2.typ := par1.typ; par1 := par2
  807.     |
  808.     OCT.pCOPY :
  809.       IF
  810.         ((f = Array) OR (f = DynArr)) & (par2.typ.BaseTyp.form = Char)
  811.       THEN
  812.         IF par2.rdOnly THEN OCS.Mark (324) END;
  813.         IF f = Array THEN
  814.           x.mode := Con; x.a0 := par2.typ.n;
  815.           IF (par1.typ.form = String) & (par1.a1 < x.a0) THEN
  816.             x.a0 := par1.a1
  817.           ELSIF (par1.typ.form = Array) & (par1.typ.n < x.a0) THEN
  818.             x.a0 := par1.typ.n
  819.           END;
  820.           DEC (x.a0); OCE.SetIntType (x)
  821.         ELSE
  822.           IF (par1.typ.form = String) & (par1.a1 = 1) THEN
  823.             x.mode := Con; x.a0 := 0; x.typ := OCT.sinttyp
  824.           ELSE OCI.DescItem (x, par2.desc, par2.typ.adr)
  825.           END
  826.         END;
  827.         OCI.CopyString (par1, par2, x)
  828.       ELSE
  829.         OCS.Mark (111)
  830.       END;
  831.       par1.typ := OCT.notyp
  832.     |
  833.     OCT.pMOVE :
  834.       IF (f IN adrSet) THEN
  835.         x.mode := Push; x.a0 := SP;
  836.         OCC.Move (L, par2, x); OCI.Unload (par2)
  837.       ELSE
  838.         OCS.Mark (111)
  839.       END
  840.     |
  841.   ELSE
  842.     OCS.Mark (1015); OCS.Mark (fctno)
  843.   END; (* CASE fctno *)
  844. END StPar2;
  845.  
  846. (*------------------------------------*)
  847. PROCEDURE StPar3 *
  848.   ( VAR p, x : OCT.Item; fctno : INTEGER; VAR R : OCC.RegState );
  849.  
  850.   VAR f : INTEGER; y : OCT.Item;
  851.  
  852. BEGIN (* StPar3 *)
  853.   f := x.typ.form;
  854.   IF fctno = OCT.pMOVE THEN
  855.     IF f IN intSet THEN
  856.       IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END;
  857.       y.mode := Push; y.a0 := SP;
  858.       OCC.Move (L, x, y); OCI.Unload (x);
  859.       OCC.CallKernel (OCC.kMove); OCC.ForgetRegs;
  860.       y.mode := Undef; OCC.RestoreRegisters (R, y)
  861.     ELSE
  862.       OCS.Mark (111)
  863.     END;
  864.     p.typ := OCT.notyp
  865.   ELSE
  866.     OCS.Mark (64)
  867.   END
  868. END StPar3;
  869.  
  870. (*------------------------------------*)
  871. PROCEDURE StFct *
  872.   ( VAR p : OCT.Item; fctno, parno : INTEGER; VAR R : OCC.RegState );
  873.  
  874.   VAR
  875.     p2, r0, r1, x, y : OCT.Item; L0 : LONGINT; f, f1, proc : INTEGER;
  876.     btyp : OCT.Struct;
  877.  
  878. BEGIN (* StFct *)
  879.   IF fctno >= OCT.TwoPar THEN
  880.     IF (fctno = OCT.pASSERT) & (parno = 1) THEN
  881.       IF p.mode # Coc THEN
  882.         OCC.PutF1 (OCC.TST, B, p);                    (*    TST.B <p>     *)
  883.         OCI.Unload (p); L0 := OCC.pc;
  884.         OCC.PutWord (OCC.BNE)                         (*    BNE.S 2$      *)
  885.       ELSE
  886.         OCC.PutWord (OCC.Bcc + (p.a0 * 100H));
  887.         OCC.PutWord (p.a1);                           (*    Bcc   2$      *)
  888.         L0 := OCC.pc - 2; OCC.FixLink (p.a2);
  889.       END;
  890.       p2.mode := Con; p2.a0 := 20; p2.typ := OCT.linttyp;
  891.       r0.mode := Reg; r0.a0 := D0;
  892.       OCC.Move (L, p2, r0); OCI.Unload (p2);  (* 1$ MOVE.L #20,D0        *)
  893.       x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  894.       x.label := OCT.ConstLabel;
  895.       OCC.PutF2 (OCC.LEA, x, A0);             (*    LEA    ModuleName,A0 *)
  896.       x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  897.       r1.mode := Reg; r1.a0 := D1;
  898.       OCC.Move (L, x, r1);                    (*    MOVE.L pos,D1        *)
  899.       OCC.CallKernel (OCC.kHalt);             (*    JSR    Kernel.Halt   *)
  900.       OCC.ForgetRegs;
  901.       IF p.mode # Coc THEN                    (* 2$                      *)
  902.         OCC.PatchWord (L0, OCC.pc - L0 - 2)
  903.       ELSE OCC.FixLink (L0)
  904.       END;
  905.       p.typ := OCT.notyp
  906.     ELSIF (fctno = OCT.pDEC) & (parno = 1) THEN
  907.       IF p.rdOnly THEN OCS.Mark (324) END;
  908.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  909.       OCC.PutF5 (OCC.SUB, p.typ.size, p2, p);
  910.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  911.       p.typ := OCT.notyp
  912.     ELSIF (fctno = OCT.pINC) & (parno = 1) THEN
  913.       IF p.rdOnly THEN OCS.Mark (324) END;
  914.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  915.       OCC.PutF5 (OCC.ADD, p.typ.size, p2, p);
  916.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  917.       p.typ := OCT.notyp
  918.     ELSIF (fctno = OCT.pLEN) & (parno = 1) THEN
  919.       IF p.typ.form = DynArr THEN OCI.DescItem (p, p.desc, p.typ.adr)
  920.       ELSE p.mode := Con; p.a0 := p.typ.n; p.typ := OCT.linttyp
  921.       END
  922.     ELSIF fctno = OCT.pINLINE THEN
  923.       p.typ := OCT.notyp
  924.     ELSIF fctno = OCT.pSYSNEW THEN
  925.       IF
  926.         ((p.typ.form = Pointer) & (p.typ.sysflg = OberonFlag))
  927.         OR (p.typ.form = PtrTyp)
  928.       THEN
  929.         OCC.PutWord (50E7H)                           (* ST     -(A7)     *)
  930.       ELSE
  931.         OCC.PutWord (51E7H)                           (* SF     -(A7)     *)
  932.       END;
  933.       OCC.CallKernel (OCC.kNewSysBlk);                (* JSR    NewSysBlk *)
  934.       IF p.typ.sysflg = BCPLFlag THEN
  935.         OCC.PutWord (0E480H)                          (* ASR.L  #2,D0     *)
  936.       END;
  937.       x.mode := Undef; OCC.ForgetRegs; OCC.RestoreRegisters (R, x);
  938.       r0.mode := Reg; r0.a0 := D0;
  939.       OCC.Move (L, r0, p);                            (* MOVE.L D0,<var>  *)
  940.       OCC.ForgetObj (p.obj); p.typ := OCT.notyp
  941.     ELSIF (parno < 2) OR (fctno = OCT.pMOVE) & (parno < 3) THEN
  942.       OCS.Mark (65)
  943.     END
  944.   ELSIF (fctno = OCT.pNEW) & (parno >= 1) THEN
  945.     f := p.typ.form;
  946.     IF f = Pointer THEN
  947.       f1 := p.typ.sysflg; btyp := p.typ.BaseTyp; f := btyp.form;
  948.       r0.mode := Reg; r0.a0 := D0;
  949.       IF (f1 = OberonFlag) & NeedsTag (btyp) THEN
  950.         IF f = Record THEN
  951.           IF parno > 1 THEN OCS.Mark (64) END;
  952.           proc := OCC.kNewRecord
  953.         ELSIF f = Array THEN
  954.           IF parno > 1 THEN OCS.Mark (64) END;
  955.           proc := OCC.kNewArray
  956.         ELSIF f = DynArr THEN
  957.           WHILE btyp.form = DynArr DO btyp := btyp.BaseTyp; DEC (parno) END;
  958.           WHILE btyp.form = Array DO btyp := btyp.BaseTyp END;
  959.           IF parno > 1 THEN OCS.Mark (64)
  960.           ELSIF parno < 1 THEN OCS.Mark (65)
  961.           END;
  962.           proc := OCC.kNewArray
  963.         END
  964.       ELSE
  965.         IF f1 = OberonFlag THEN
  966.           IF f = DynArr THEN
  967.             WHILE btyp.form = DynArr DO
  968.               btyp := btyp.BaseTyp; DEC (parno)
  969.             END;
  970.             IF parno > 1 THEN OCS.Mark (64)
  971.             ELSIF parno < 1 THEN OCS.Mark (65)
  972.             END
  973.           END;
  974.           OCC.PutWord (50E7H)                     (* ST     -(A7)        *)
  975.         ELSE
  976.           OCC.PutWord (51E7H)                     (* SF     -(A7)        *)
  977.         END;
  978.         proc := OCC.kNewSysBlk
  979.       END;
  980.       OCC.CallKernel (proc);
  981.       IF f1 = BCPLFlag THEN OCC.PutWord (0E480H) END;(* ASR.L  #2,D0     *)
  982.       x.mode := Undef; OCC.ForgetRegs; OCC.RestoreRegisters (R, x);
  983.       OCC.Move (L, r0, p);                           (* MOVE.L D0,<var>  *)
  984.       OCC.ForgetObj (p.obj)
  985.     END;
  986.     p.typ := OCT.notyp
  987.   ELSIF parno < 1 THEN
  988.     OCS.Mark (65)
  989.   END
  990. END StFct;
  991.  
  992. (*------------------------------------*)
  993. PROCEDURE Inline * (VAR x : OCT.Item);
  994.  
  995.   VAR f : INTEGER;
  996.  
  997. BEGIN (* Inline *)
  998.   f := x.typ.form;
  999.   IF (f IN intSet) & (x.mode = Con) THEN
  1000.     IF f = LInt THEN OCC.PutLong (x.a0)
  1001.     ELSE OCC.PutWord (x.a0)
  1002.     END
  1003.   ELSE
  1004.     OCS.Mark (17)
  1005.   END
  1006. END Inline;
  1007.  
  1008. (*------------------------------------*)
  1009. PROCEDURE NewPar * (VAR x, p0, p1 : OCT.Item; n : INTEGER);
  1010.  
  1011.   VAR f, i : INTEGER; btyp : OCT.Struct; desc, r0, y : OCT.Item;
  1012.       calcSize : BOOLEAN;
  1013.  
  1014. BEGIN (* NewPar *)
  1015.   IF p1.typ.form IN intSet THEN
  1016.     f := x.typ.form;
  1017.     IF (f = Pointer) & (x.typ.sysflg = OberonFlag) THEN
  1018.       btyp := x.typ; i := 0;
  1019.       WHILE (btyp.BaseTyp # NIL) & (i < n) DO
  1020.         btyp := btyp.BaseTyp; INC (i)
  1021.       END;
  1022.       f := btyp.form;
  1023.       IF f = DynArr THEN
  1024.         IF p1.typ.form # LInt THEN OCE.ConvertInts (p1, OCT.linttyp) END;
  1025.         OCI.DescItem (desc, x.desc, btyp.adr);
  1026.         OCC.Move (L, p1, desc);
  1027.         OCI.UpdateDesc (desc, btyp.adr);
  1028.         btyp := btyp.BaseTyp; f := btyp.form;
  1029.         IF p1.mode = Con THEN
  1030.           IF f # DynArr THEN p1.a0 := p1.a0 * btyp.size END;
  1031.           calcSize := FALSE
  1032.         ELSE
  1033.           calcSize := TRUE
  1034.         END;
  1035.         IF n = 1 THEN p0 := p1
  1036.         ELSE OCE.Op (OCS.times, p0, p1, TRUE)
  1037.         END;
  1038.         IF calcSize & (f # DynArr) & (btyp.size > 1) THEN
  1039.           y.mode := Con; y.a0 := btyp.size; y.typ := OCT.linttyp;
  1040.           OCE.Op (OCS.times, p0, y, TRUE)
  1041.         END;
  1042.         IF f # DynArr THEN
  1043.           OCI.UnloadDesc (x);
  1044.           y.mode := Push; y.a0 := SP;
  1045.           OCC.Move (L, p0, y); OCI.Unload (p0)
  1046.         END;
  1047.       ELSE OCS.Mark (64)
  1048.       END
  1049.     ELSE OCS.Mark (64)
  1050.     END
  1051.   ELSE OCS.Mark (328)
  1052.   END
  1053. END NewPar;
  1054.  
  1055. END OCP.
  1056.  
  1057. (***************************************************************************
  1058.  
  1059.   $Log: OCP.mod $
  1060.   Revision 5.17  1995/07/14  00:43:53  fjc
  1061.   - Special-cased SYSTEM.ADR in the small data model to avoid
  1062.     running out of registers in VarArg parameter lists.
  1063.  
  1064.   Revision 5.16  1995/06/29  19:10:59  fjc
  1065.   - Removed code that was second-guessing the garbage collector
  1066.  
  1067.   Revision 5.15  1995/06/02  18:41:18  fjc
  1068.   - Various changes to implement the SMALLDATA and RESIDENT
  1069.     options.
  1070.   - Now uses OCI.CMP.
  1071.  
  1072.   Revision 5.14  1995/05/13  23:08:42  fjc
  1073.   - Changed INTEGER to LONGINT where necessary.
  1074.  
  1075.   Revision 5.13  1995/05/08  17:07:09  fjc
  1076.   - OCI.IsParam() --> OCT.IsParam().
  1077.  
  1078.   Revision 5.11  1995/03/09  19:10:56  fjc
  1079.   - Incorporated changes from 5.22.
  1080.  
  1081.   Revision 5.10  1995/02/27  17:05:20  fjc
  1082.   - Removed tracing code.
  1083.   - Changed to use new register handling procedures.
  1084.  
  1085.   Revision 5.9.1.1  1995/03/08  19:20:29  fjc
  1086.   - OC 5.22
  1087.  
  1088.   Revision 5.9  1995/01/26  00:17:17  fjc
  1089.   - Release 1.5
  1090.  
  1091.   Revision 5.8  1995/01/03  21:22:07  fjc
  1092.   - Changed OCG to OCM.
  1093.  
  1094.   Revision 5.7  1994/12/16  17:33:01  fjc
  1095.   - Changed Symbol to Label.
  1096.  
  1097.   Revision 5.6  1994/11/13  11:31:33  fjc
  1098.   - Changed handling of ENTIER.
  1099.   - [bug] ABS now implemented for reals.
  1100.   - Implemented SYSTEM.CC.
  1101.  
  1102.   Revision 5.5  1994/10/23  16:16:31  fjc
  1103.   - Complete overhaul:
  1104.     - Added SaveRegs().
  1105.     - Removed code for handling obsolete SYSTEM procedures:
  1106.       GC, RC, ARGLEN, ARGS, SIZETAG, SETCLEANUP, BIND,
  1107.       GETNAME and NEWTAG.
  1108.     - All access to RTS is now through OCC.CallKernel().
  1109.  
  1110.   Revision 5.4  1994/09/25  18:01:55  fjc
  1111.   - Changed to reflect new object modes and system flags.
  1112.  
  1113.   Revision 5.3  1994/09/15  10:36:36  fjc
  1114.   - Replaced switches with pragmas.
  1115.  
  1116.   Revision 5.2  1994/09/08  10:50:49  fjc
  1117.   - Changed to use pragmas/options.
  1118.  
  1119.   Revision 5.1  1994/09/03  19:29:08  fjc
  1120.   - Bumped version number
  1121.  
  1122. ***************************************************************************)
  1123.